home *** CD-ROM | disk | FTP | other *** search
/ Aminet 4 / Aminet 4 - November 1994.iso / aminet / dev / obero / oberon_lib.lha / oberon-a / source1.lha / source / Library / StdIO.mod < prev    next >
Text File  |  1994-08-08  |  11KB  |  377 lines
  1. (***************************************************************************
  2.  
  3.      $RCSfile: StdIO.mod $
  4.   Description: Simple formatted I/O using the standard input and output
  5.                handles.
  6.  
  7.    Created by: fjc (Frank Copeland)
  8.     $Revision: 1.8 $
  9.       $Author: fjc $
  10.         $Date: 1994/08/08 16:25:24 $
  11.  
  12.   Copyright © 1994, Frank Copeland.
  13.   This file is part of the Oberon-A Library.
  14.   See Oberon-A.doc for conditions of use and distribution.
  15.  
  16. ***************************************************************************)
  17.  
  18. MODULE StdIO;
  19.  
  20. (*
  21. ** $C= CaseChk       $I= IndexChk  $L+ LongAdr   $N- NilChk
  22. ** $P- PortableCode  $R= RangeChk  $S= StackChk  $T= TypeChk
  23. ** $V= OvflChk       $Z= ZeroVars
  24. *)
  25.  
  26. IMPORT
  27.   SYS := SYSTEM, Exec, Dos, WB := Workbench, Icon, Args, Errors,
  28.   Reals;
  29.  
  30. VAR
  31.   enableBreak * : BOOLEAN;
  32.  
  33. CONST
  34.   DefWbConsole = "CON:40/12/480/150/Oberon-A StdIO Window";
  35.   maxD = 9;
  36.  
  37. VAR
  38.   WbConsole  : Dos.FileHandlePtr;
  39.  
  40. (*------------------------------------*)
  41. PROCEDURE^ CheckBreak ();
  42.  
  43. (*------------------------------------*)
  44. PROCEDURE Write* (ch : CHAR);
  45.  
  46. BEGIN (* Write *)
  47.   CheckBreak ();
  48.   SYS.PUTREG (0, Dos.base.Write (Dos.base.Output(), ch, 1))
  49. END Write;
  50.  
  51. (*------------------------------------*)
  52. PROCEDURE WriteLn*;
  53.  
  54. BEGIN (* WriteLn *)
  55.   Write (0AX)
  56. END WriteLn;
  57.  
  58. (*------------------------------------*)
  59. PROCEDURE WriteStr* (s : ARRAY OF CHAR);
  60.  
  61. (* $D- Disables copying of dynamic array parameters. *)
  62. BEGIN (* WriteStr *)
  63.   CheckBreak ();
  64.   SYS.PUTREG (0, Dos.base.Write (Dos.base.Output (), s, SYS.STRLEN (s)))
  65. END WriteStr;
  66.  
  67. (*
  68. ** $S- Disable compiler stack checking.
  69. **
  70. ** CheckBreak() is always called from within a procedure which has already
  71. ** done it, and PutCh() won't work with it on.
  72. *)
  73.  
  74. (*------------------------------------*)
  75. PROCEDURE CheckBreak ();
  76.  
  77.   VAR signals : SET;
  78.  
  79. BEGIN (* CheckBreak *)
  80.   IF enableBreak THEN
  81.     signals := Exec.base.SetSignal ({}, {});
  82.     IF Dos.sigBreakCtrlC IN signals THEN
  83.       enableBreak := FALSE;
  84.       WriteStr ("\n***BREAK -- User aborted\n");
  85.       HALT (Dos.returnWarn)
  86.     END
  87.   END
  88. END CheckBreak;
  89.  
  90. (*------------------------------------*)
  91. PROCEDURE* PutCh ();
  92.  
  93. BEGIN (* PutCh *)
  94.   SYS.INLINE (16C0H)   (* MOVE.B D0,(A3)+ *)
  95. END PutCh;
  96. (* $S= Enable compiler stack checking *)
  97.  
  98. (*------------------------------------*)
  99. PROCEDURE WriteInt* (i : LONGINT);
  100.  
  101.   VAR
  102.     str : ARRAY 256 OF CHAR;
  103.  
  104. BEGIN (* WriteInt *)
  105.   Exec.base.OldRawDoFmtL ("%ld", i, PutCh, SYS.ADR (str));
  106.   WriteStr (str)
  107. END WriteInt;
  108.  
  109. (*------------------------------------*)
  110. PROCEDURE WriteHex* (i : LONGINT);
  111.  
  112.   VAR
  113.     str : ARRAY 256 OF CHAR;
  114.  
  115. BEGIN (* WriteHex *)
  116.   Exec.base.OldRawDoFmtL ("%lx", i, PutCh, SYS.ADR (str));
  117.   WriteStr (str)
  118. END WriteHex;
  119.  
  120. (*
  121.  * The following WriteReal* and WriteLongReal* procedures have been pinched
  122.  * from Module Texts and have been somewhat modified from the original code
  123.  * described in "Project Oberon".
  124.  *)
  125.  
  126. (*------------------------------------*)
  127. PROCEDURE WriteReal * ( x : REAL; n : INTEGER );
  128.  
  129.   VAR e : INTEGER; x0 : REAL; d : ARRAY maxD OF CHAR;
  130.  
  131. BEGIN (* WriteReal *)
  132.   (*
  133.    * This implementation uses Motorola FFP format reals instead of IEEE
  134.    * single-precision reals.  The Project Oberon code has been modified to
  135.    * remove the special-case handling of unnormal and NaN values and assume
  136.    * 7-bit exponents instead of 8-bit.
  137.    *)
  138.   e := Reals.Expo (x);
  139.   IF n <= 9 THEN n := 3 ELSE DEC (n, 6) END;
  140.   REPEAT Write (" "); DEC (n) UNTIL n <= 8;
  141.   (* there are 2 < n <= 8 digits to be written *)
  142.   IF x < 0.0 THEN Write ("-"); x := -x ELSE Write (" ") END;
  143.   e := (e - 64) * 77 DIV 256;
  144.   IF e >= 0 THEN x := x / Reals.Ten (e) ELSE x := Reals.Ten (-e) * x END;
  145.   IF x >= 10.0 THEN x := 0.1 * x; INC (e) END;
  146.   x0 := Reals.Ten (n - 1); x := x0 * x + 0.5;
  147.   IF x >= 10.0 * x0 THEN x := x * 0.1; INC (e) END;
  148.   Reals.Convert (x, n, d);
  149.   DEC (n); Write (d [n]); Write (".");
  150.   REPEAT DEC (n); Write (d [n]) UNTIL n = 0;
  151.   Write ("E");
  152.   IF e < 0 THEN Write ("-"); e := -e ELSE Write ("+") END;
  153.   Write (CHR (e DIV 10 + 30H)); Write (CHR (e MOD 10 + 30H))
  154. END WriteReal;
  155.  
  156. (*------------------------------------*)
  157. PROCEDURE WriteRealFix * ( x : REAL; n, k : INTEGER );
  158.  
  159.   VAR e, i : INTEGER; sign : CHAR; x0 : REAL; d : ARRAY maxD OF CHAR;
  160.  
  161.   (*------------------------------------*)
  162.   PROCEDURE seq ( ch : CHAR; n : LONGINT );
  163.  
  164.   BEGIN (* seq *)
  165.     WHILE n > 0 DO Write (ch); DEC (n) END
  166.   END seq;
  167.  
  168.   (*------------------------------------*)
  169.   PROCEDURE dig (n : INTEGER);
  170.  
  171.   BEGIN (* dig *)
  172.     WHILE n > 0 DO
  173.       DEC (i); Write (d [i]); DEC (n)
  174.     END;
  175.   END dig;
  176.  
  177. BEGIN (* WriteRealFix *)
  178.   (*
  179.    * This implementation uses Motorola FFP format reals instead of IEEE
  180.    * single-precision reals.  The Project Oberon code has been modified to
  181.    * remove the special-case handling of unnormal and NaN values and assume
  182.    * 7-bit exponents instead of 8-bit.
  183.    *)
  184.   IF k < 0 THEN k := 0 END;
  185.   e := (Reals.Expo (x) - 64) * 77 DIV 256;
  186.   IF x < 0.0 THEN sign := "-"; x := -x ELSE sign := " " END;
  187.   IF e >= 0 THEN (* x >= 1.0, 77/256 = log 2 *) x := x / Reals.Ten (e)
  188.   ELSE (* x < 1.0 *) x := Reals.Ten (-e) * x END;
  189.   IF x >= 10.0 THEN x := 0.1 * x; INC (e) END;
  190.   (* 1 <= x < 10 *)
  191.   IF k + e >= maxD - 1 THEN k := maxD - 1 - e
  192.   ELSIF k + e < 0 THEN k := -e; x := 0.0
  193.   END;
  194.   x0 := Reals.Ten (k + e); x := x0 * x + 0.5;
  195.   IF x >= 10.0 * x0 THEN INC (e) END;
  196.   (* e = no. of digits before decimal point *)
  197.   INC (e); i := k + e; Reals.Convert (x, i, d);
  198.   IF e > 0 THEN
  199.     seq (" ", n - e - k - 2); Write (sign); dig (e); Write (".");
  200.     dig (k)
  201.   ELSE
  202.     seq (" ", n - k - 3); Write (sign); Write ("0"); Write (".");
  203.     seq ("0", -e); dig (k + e)
  204.   END; (* ELSE *)
  205. END WriteRealFix;
  206.  
  207. (*------------------------------------*)
  208. PROCEDURE WriteRealHex * ( x : REAL );
  209.  
  210.   VAR d : ARRAY 9 OF CHAR;
  211.  
  212. BEGIN (* WriteRealHex *)
  213.   Reals.ConvertH (x, d); d [8] := 0X; WriteStr (d)
  214. END WriteRealHex;
  215.  
  216. (*------------------------------------*)
  217. PROCEDURE WriteLongReal * ( x : LONGREAL; n : INTEGER );
  218.  
  219. BEGIN (* WriteLongReal *)
  220.   (*
  221.    * In this implementation, LONGREAL and REAL types are the same, so this
  222.    * procedure is implemented as a call to WriteReal ().
  223.    *)
  224.   WriteReal (SHORT (x), n)
  225. END WriteLongReal;
  226.  
  227. (*------------------------------------*)
  228. PROCEDURE WriteLongRealHex * ( x : LONGREAL );
  229.  
  230. BEGIN (* WriteLongRealHex *)
  231.   (*
  232.    * In this implementation, LONGREAL and REAL types are the same, so this
  233.    * procedure is implemented as a call to WriteRealHex ().
  234.    *)
  235.   WriteRealHex (SHORT (x))
  236. END WriteLongRealHex;
  237.  
  238. (*------------------------------------*)
  239. (* $D- Disables copying of dynamic array parameters. *)
  240. PROCEDURE WriteF* (
  241.   fs : ARRAY OF CHAR; VAR f : ARRAY OF SYS.LONGWORD);
  242.  
  243.   VAR
  244.     str : ARRAY 256 OF CHAR;
  245.  
  246. BEGIN (* WriteF *)
  247.   Exec.base.OldRawDoFmtL (fs, f, PutCh, SYS.ADR (str));
  248.   WriteStr (str)
  249. END WriteF;
  250.  
  251. (*------------------------------------*)
  252. (* $D- Disables copying of dynamic array parameters. *)
  253. PROCEDURE WriteF1*
  254.   ( fs     : ARRAY OF CHAR;
  255.     param1 : SYS.LONGWORD);
  256.  
  257.   VAR str : ARRAY 256 OF CHAR;
  258.  
  259. BEGIN (* WriteF1 *)
  260.   Exec.base.OldRawDoFmtL (fs, param1, PutCh, SYS.ADR (str));
  261.   WriteStr (str)
  262. END WriteF1;
  263.  
  264. (*------------------------------------*)
  265. (* $D- Disables copying of dynamic array parameters. *)
  266. PROCEDURE WriteF2* (
  267.   fs : ARRAY OF CHAR; param1, param2 : SYS.LONGWORD);
  268.  
  269.   VAR str : ARRAY 256 OF CHAR; t : SYS.LONGWORD;
  270.  
  271. BEGIN (* WriteF2 *)
  272.   t := param1; param1 := param2; param2 := t;
  273.   Exec.base.OldRawDoFmtL (fs, param2, PutCh, SYS.ADR (str));
  274.   WriteStr (str)
  275. END WriteF2;
  276.  
  277. (*------------------------------------*)
  278. (* $D- Disables copying of dynamic array parameters. *)
  279. PROCEDURE WriteF3* (
  280.   fs : ARRAY OF CHAR; param1, param2, param3 : SYS.LONGWORD);
  281.  
  282.   VAR str : ARRAY 256 OF CHAR; t : SYS.LONGWORD;
  283.  
  284. BEGIN (* WriteF3 *)
  285.   t := param1; param1 := param3; param3 := t;
  286.   Exec.base.OldRawDoFmtL (fs, param3, PutCh, SYS.ADR (str));
  287.   WriteStr (str)
  288. END WriteF3;
  289.  
  290. (*------------------------------------*)
  291. PROCEDURE Read* (VAR ch : CHAR);
  292.  
  293. BEGIN (* Read *)
  294.   CheckBreak ();
  295.   IF Dos.base.Read (Dos.base.Input (), ch, 1) < 1 THEN ch := 0X END;
  296. END Read;
  297.  
  298. (*------------------------------------*)
  299. PROCEDURE ReadStr* (VAR str : ARRAY OF CHAR);
  300.  
  301.   VAR ch : CHAR; index, limit : INTEGER;
  302.  
  303. BEGIN (* ReadStr *)
  304.   (* Skip white space *)
  305.   REPEAT Read (ch) UNTIL (ch # " ") & (ch # 09X);
  306.   (* Read until control char *)
  307.   index := 0; limit := SHORT (LEN (str));
  308.   WHILE (ch >= " ") & (index < limit) DO
  309.     str [index] := ch; INC (index); Read (ch);
  310.   END; (* WHILE *)
  311.   str [index] := 0X;
  312.   (* Skip rest of line if any *)
  313.   WHILE ch >= " " DO Read (ch) END;
  314. END ReadStr;
  315.  
  316. (* $L- Access global variables through A4 *)
  317. (*------------------------------------*)
  318. PROCEDURE* CloseWbConsole ();
  319.  
  320. BEGIN (* CloseWbConsole *)
  321.   IF WbConsole # NIL THEN Dos.base.OldClose (WbConsole) END;
  322. END CloseWbConsole;
  323.  
  324. (*------------------------------------*)
  325. PROCEDURE SetupWbConsole ();
  326.  
  327.   VAR
  328.     oldDir    : Dos.FileLockPtr;
  329.     console   : Exec.STRPTR;
  330.     diskObj   : WB.DiskObjectPtr;
  331.     toolTypes : WB.ToolTypePtr;
  332.     process   : Dos.ProcessPtr;
  333.     conTask   : Exec.MsgPortPtr;
  334.  
  335. BEGIN (* SetupWbConsole *)
  336.   (* Make sure icon.library is open *)
  337.   Icon.OpenLib (TRUE);
  338.  
  339.   (* First CD to the app's directory *)
  340.   oldDir := Dos.base.CurrentDir (Args.ArgList [0].lock);
  341.   (* Attempt to load the app's icon *)
  342.   diskObj := Icon.base.GetDiskObject (Args.ArgList [0].name^);
  343.   IF diskObj # NIL THEN
  344.     (* Look for a "WINDOW=" tooltype *)
  345.     console := Icon.base.FindToolType (diskObj.toolTypes, "WINDOW");
  346.     (*
  347.      *  We will free diskObj AFTER we have finished with console.  Guess
  348.      *  who got it wrong? :-)
  349.      *)
  350.   END; (* IF *)
  351.   (* Back to where we started *)
  352.   oldDir := Dos.base.CurrentDir (oldDir);
  353.  
  354.   (* Open the console window *)
  355.   IF console = NIL THEN console := SYS.ADR (DefWbConsole) END;
  356.   WbConsole := Dos.base.Open (console^, Dos.modeNewFile);
  357.   IF diskObj # NIL THEN Icon.base.FreeDiskObject (diskObj) END;
  358.   Errors.Assert (WbConsole # NIL, "Could not open StdIO window");
  359.  
  360.   (*
  361.    *  Set the console task (so Input(), Output() & Open("*", mode) will
  362.    *  work).  This is from Commodore's startup.asm.
  363.    *)
  364.   process := SYS.VAL (Dos.ProcessPtr, Exec.base.FindTask (NIL));
  365.   process.cis := WbConsole;
  366.   process.cos := WbConsole;
  367.   conTask := WbConsole.type;
  368.   IF conTask # NIL THEN process.consoleTask := conTask END;
  369.  
  370.   SYS.SETCLEANUP (CloseWbConsole);
  371. END SetupWbConsole;
  372.  
  373. BEGIN
  374.   enableBreak := TRUE;
  375.   IF ~Args.IsCLI THEN SetupWbConsole () END
  376. END StdIO.
  377.